;;;; With the facilities programmed in this file it is possible to get access
;;;; to LAML SchemeDoc information from Emacs.
;;;; The interactive entry functions are display-schemedoc-information and reset-schemedoc-information 
;;;; Relevant keybindings are found in the file emacs-support/laml-key-menu-bindings.el

; SchemeDoc mode, backed by the file extension sdoc.

(define-derived-mode 
	schemedoc-mode laml-mode "SchemeDoc" 
  "A LAML Scheme Emacs mode mode, which binds some keys (see below) to a useful SchemeDoc functionality."

  (font-lock-mode t)

)

; ---------------------------------------------------------------------------------------------------------------
; SchemeDoc keybindings.

(laml-define-key schemedoc-mode-map [menu-bar schemedoc]
    (cons "SchemeDoc" (make-sparse-keymap "SchemeDoc")))

(laml-define-key  schemedoc-mode-map [menu-bar schemedoc insert-documentation-entry]
      '("Insert manual page" . (lambda () (interactive) (laml-insert-template "manual-page-xml-in-laml"))))

(laml-define-key schemedoc-mode-map [menu-bar schemedoc insert-documentation-section]
      '("Insert manual section" . (lambda () (interactive) (laml-insert-template "manual-section-xml-in-laml"))))




; ---------------------------------------------------------------------------------------------------------------------------------------
; SchemeDoc functionality relevant on Scheme source files.


; Buffer local variables:
(defvar schemedoc-manlsp-file-list nil
  "A list of relative or absolute file names of manlsp files (without extension) to take into consideration when displaying
SchemeDoc help info. Relative files are relative to the directory of the current Scheme source file. Initialized
the first time you enquire about documentation.")

(defvar documented-scheme-names-alist nil 
  "An a-list of Scheme names for which there is access to SchemeDoc documentation. Maps to the number of the SchemeDoc file in schemedoc-manlsp-file-list")


(defvar schemedoc-preferred-linelength 80 "The preferred line length of text shown by LAML SchemeDoc")

; How to display SchemeDoc information.
(defvar schemedoc-display-mode 'help-buffer
  "How to display extracted SchemeDoc documentation in Emacs. Either help-buffer, tooltip, or nil") 

(defun display-schemedoc-information ()
  "Display SchemeDoc information of the name under point. This is the top level LAML SchemeDoc support function in Emacs.
Use of this function provides access to SchemeDoc manual information, as represented in -.manlsp files. The manlsp
files are generated by LAML SchemeDoc."
  (interactive)
   (let ((back-count 0))
    (if (null documented-scheme-names-alist) 
           (progn
              (message "First time use of SchemeDoc in this buffer. Initializing. Please wait...")
              (reset-schemedoc-information)
           ))
    (while (looking-at-white-space (point)) (backward-char 1) (setq back-count (+ back-count 1)))
    (let ((name-0 (prog-name-under-point-schemedoc)))
     (forward-char back-count)
     (let* ((name-1 (if (assoc name-0 documented-scheme-names-alist) name-0 ""))
            (name (completing-read "Describe defined Scheme name: " documented-scheme-names-alist nil nil name-1))
            (file-number (schemedoc-file-number-of-name name))
            (file-name (if file-number (file-path-of-file-number file-number) nil))
            (doc-entry (find-schemedoc-documentation-of-name-given-number name file-number))
           )
      (if doc-entry
          (cond ((eq schemedoc-display-mode 'help-buffer)
                    (schemedoc-help-buffer (format-schemedoc-entry doc-entry file-name)))
                ((eq schemedoc-display-mode 'tooltip)
                    (tooltip-show (format-schemedoc-entry doc-entry file-name)))
                ((eq schemedoc-display-mode 'minibuffer)
                    (message (format-schemedoc-entry doc-entry file-name)))
                ((eq schemedoc-display-mode nil)
                       'nothing-showed)
                (t (error "display-schemedoc-information. Unexpected value of schemedoc-display-mode")))
          (beep))))))

(defun prog-name-under-point-schemedoc ()
  "As prog-name-under-point, but can only return a proper name. 
In case of problems, return nil."
  (cond ((looking-at-white-space (point)) nil)
        ((looking-at ";") nil)
        ((or (looking-at "(") (looking-at ")")) nil)
        (t (prog-name-under-point))))

(defun reset-schemedoc-information ()
  "Re-read the schemedoc files to take into account from the current Scheme source file.
Also re-read the LAML SchemeDoc information from the internal SchemeDoc files pointed out by schemedoc-manlsp-file-list."
  (interactive)
  (init-schemedoc-file-list-from-current-scheme-source)
  (init-name-completion)
  (schemedoc-manlsp-file-list-message)
)

(defun schemedoc-manlsp-file-list-message ()
  (message
    (concat 
      "The following SchemeDoc resources are effective: "
      (list-to-string-with-sep
        (mapcar (function (lambda (f) (file-name-proper (file-name-nondirectory f)))) schemedoc-manlsp-file-list) ", "))))

(defun info-emacs-schemedoc ()
  (interactive)
  (if (null schemedoc-manlsp-file-list)
      (progn
        (init-schemedoc-file-list-from-current-scheme-source)
        (init-name-completion)
        (schemedoc-manlsp-file-list-message))
      (schemedoc-manlsp-file-list-message)))
         
  

(defun list-to-string-with-sep (string-list sep)
  (cond ((null string-list) "")
        ((null (cdr string-list)) (car string-list))
        (t (concat (car string-list) sep (list-to-string-with-sep (cdr string-list) sep)))))

(defun init-schemedoc-file-list-from-current-scheme-source ()
  (make-variable-buffer-local 'schemedoc-manlsp-file-list)
  (let ((lst (schemedoc-file-list-from-current-scheme-source)))
    (setq schemedoc-manlsp-file-list 
          (filter (function (lambda (el) (not (null el)))) lst))))

(defun schemedoc-file-list-from-current-scheme-source ()
 "Return the current buffers SchemeDoc file list (the list of manlsp files from where to extract SchemeDoc information).
Depending on the major/minor modes of the buffer, a fixed set of manuals are taken into account.
In addition, the special tag  .schemedoc-dependencies  can be used to enumerate other manuals.
Place, for instance, the  .schemedoc-dependencies  tag in the introductory comment of the Scheme source file." 
 (let ((default-schemedoc-list
          (cond ((and (eq major-mode 'laml-mode) (boundp 'elucidator-buffer-info) (eq elucidator-buffer-info 'setup))
                                                  (list (concat laml-dir "r5rs/man/r5rs") 
                                                        (concat laml-dir "man/laml")  (concat laml-dir "lib/man/general")
                                                        (concat laml-dir "lib/compatibility/man/compatibility")
                                                        (concat laml-dir "styles/xml-in-laml/elucidator-2/man/elucidator")
                                                 ))
                ((eq major-mode 'schemedoc-mode)  (list (concat laml-dir "r5rs/man/r5rs")
                                                        (concat laml-dir "man/laml")  (concat laml-dir "lib/man/general") 
                                                        (concat laml-dir "lib/compatibility/man/compatibility")
                                                        (concat laml-dir "styles/xml-in-laml/schemedoc-2/man/schemedoc")
                                                        (concat laml-dir "styles/xml-in-laml/schemedoc-index/man/schemedoc-index")
                                                        (concat laml-dir "lib/xml-in-laml/mirrors/man/xhtml10-transitional-mirror")
                                                  ))

                ((eq major-mode 'scheme-mode) (list (concat laml-dir "r5rs/man/r5rs") 
                                                    (concat laml-dir "man/laml") 
                                                    (concat laml-dir "lib/xml-in-laml/man/xml-in-laml")
                                                    (concat laml-dir "lib/xml-in-laml/mirrors/man/xhtml10-transitional-mirror")
                                                    (concat laml-dir "lib/man/xhtml10-convenience")
                                                    (concat laml-dir "lib/man/general")
                                                    (concat laml-dir "lib/compatibility/man/compatibility")
                                                    (concat laml-dir "lib/man/color") (concat laml-dir "lib/man/time") 
                                                    (concat laml-dir "lib/man/file-read")
                                              ))

                ((eq major-mode 'leno-mode)   (list (concat laml-dir "r5rs/man/r5rs")
                                                    (concat laml-dir "man/laml")  (concat laml-dir "lib/man/general")
                                                    (concat laml-dir "lib/compatibility/man/compatibility")
                                                    (concat laml-dir "styles/xml-in-laml/lecture-notes/man/lecture-notes")
                                                    (concat laml-dir "styles/xml-in-laml/lecture-notes-themes/man/lecture-notes-themes")
                                                    (concat laml-dir "lib/xml-in-laml/mirrors/man/xhtml10-transitional-mirror")
                                                    (concat laml-dir "lib/man/color") (concat laml-dir "lib/man/time")
                                                    (concat laml-dir "lib/man/svg-extensions") 
                                                    (concat laml-dir "lib/man/file-read")
                                              ))

                ((eq major-mode 'chords-mode) (list (concat laml-dir "r5rs/man/r5rs")
                                                    (concat laml-dir "man/laml")  (concat laml-dir "lib/man/general")
                                                    (concat laml-dir "lib/compatibility/man/compatibility")
                                                    (concat laml-dir "styles/xml-in-laml/chords/man/chords")
                                              ))

                ((eq major-mode 'midi-laml-mode) (list 
                                                    (concat laml-dir "r5rs/man/r5rs")
                                                    (concat laml-dir "man/laml")  (concat laml-dir "lib/man/general")
                                                    (concat laml-dir "lib/compatibility/man/compatibility")
                                                    (concat laml-dir "lib/xml-in-laml/man/xml-in-laml")
                                                    (concat laml-dir "styles/xml-in-laml/midi/man/midi-mirror")
                                                    (concat laml-dir "styles/xml-in-laml/midi/man/midi-laml-processing-lib")
                                              ))

                ((eq major-mode 'laml-mode)   (list (concat laml-dir "r5rs/man/r5rs")
                                                    (concat laml-dir "man/laml") 
                                                    (concat laml-dir "lib/man/general")
                                                    (concat laml-dir "lib/compatibility/man/compatibility")
                                                    (concat laml-dir "lib/xml-in-laml/man/xml-in-laml")
                                                    (concat laml-dir "lib/xml-in-laml/mirrors/man/xhtml10-transitional-mirror")
                                                    (concat laml-dir "lib/man/xhtml10-convenience")
                                                    (concat laml-dir "lib/man/color") (concat laml-dir "lib/man/time") 
                                                    (concat laml-dir "lib/man/file-read")))

                ((eq major-mode 'inferior-lisp-mode)                                       ; Scheme command prompt
                                              (list (concat laml-dir "r5rs/man/r5rs")
                                              ))
                (t nil))))
  (save-excursion
    (goto-char (point-min))
    (let ((search-res (search-forward ".schemedoc-dependencies" nil t)))
      (append
        (if search-res
	    (mapcar (function normalize-schemedoc-dependency-file-path) (read-strings-from-scheme-source))
          nil)
        default-schemedoc-list)))))

(defun read-strings-from-scheme-source()
  "Return the list of file paths, as given in quoted strings on the current line. Stops when a newline is encountered."
  (while (not (or (= (char-under-point) 34) (= (char-under-point) 10))) (forward-char 1))
  (if (= (char-under-point) 10)
      nil
      (let ((p1 (point))
            (str nil))
        (forward-sexp 1)
        (cons (buffer-substring-no-properties (+ p1 1) (- (point) 1))
              (read-strings-from-scheme-source)))))

(defun normalize-schemedoc-dependency-file-path (file-path)
  (let* ((file-path-1 (eliminate-tilde-prefix file-path))
         (path (file-name-directory file-path-1))
         (prop (file-name-proper (file-name-nondirectory file-path-1))))
   (concat path prop)))

 
(defun init-name-completion ()
  "Initialize documented-scheme-names-alist from the internal SchemeDoc manlsp files pointed out by the list schemedoc-manlsp-file-list"
  (make-variable-buffer-local 'documented-scheme-names-alist)
  (message "Setting up SchemeDoc support...")
  (let* ((manlsp-list-list (mapcar (function file-read-schemedoc) schemedoc-manlsp-file-list))
	 (documented-scheme-names-list (mapcar (function (lambda (manlsp-list) (mapcar (function (lambda (manlsp-entry) (assoc-get 'title manlsp-entry))) manlsp-list))) manlsp-list-list))
	 (filtered-documented-scheme-names-list (mapcar (function (lambda (name-list) (filter (function (lambda (e) e)) name-list))) documented-scheme-names-list))
	 (filtered-documented-scheme-names-alist  (mapcar2 (function (lambda (name-list n) (mapcar (function (lambda (name) (cons name n))) name-list))) filtered-documented-scheme-names-list (number-interval 1 (length schemedoc-manlsp-file-list)))))

    (setq documented-scheme-names-alist
	  (apply (function append) filtered-documented-scheme-names-alist))))



(defun schemedoc-help-buffer (txt)
  (let ((help-buffer (if (get-buffer "*Help*") (get-buffer "*Help*") (generate-new-buffer "*Help*"))))
    (delete-other-windows)
    (split-window)
    (show-buffer (other-window 1) help-buffer)
    (set-buffer help-buffer)
    (toggle-read-only -1)
    (erase-buffer)
    (insert txt) (goto-char (point-min))
    (toggle-read-only 1)
    (set-buffer-modified-p nil)
    (other-window 1)))



(defun format-schemedoc-entry (doc-entry informative-file-path)
  (let ((source (assoc-get 'source doc-entry))
        (form (assoc-get 'form doc-entry))
        (title (assoc-get 'title doc-entry))
        (descr (assoc-get 'description doc-entry))
        (returns (assoc-get 'returns doc-entry))
        (parameters (assoc-get-cdr 'parameters doc-entry))
        (attributes (assoc-get-cdr 'attributes doc-entry))
        (xml-in-laml-attributes (assoc-get-cdr 'xml-in-laml-attributes doc-entry))   ; attributes of XML-in-LAML abstractions
        (attribute-descriptions (assoc-get-cdr 'attribute-descriptions doc-entry))
        (content-model (assoc-get 'content-model doc-entry))
        (laml-resource (assoc-get 'laml-resource doc-entry))
        (scheme-source (assoc-get 'scheme-source-file doc-entry))
       )
    (setq lll laml-resource) (setq sss scheme-source)
    (concat (if source (concat "Documentation from: " source CR) "")
            (cond 
               ((and laml-resource (equal laml-resource "true") scheme-source) (concat "LAML Scheme source file: " scheme-source))
               (scheme-source (concat "Scheme source file: " scheme-source))
               (informative-file-path (concat "Location of documentation: " informative-file-path CR))
               (t ""))
            (if (or source informative-file-path) CR "")
            (cond (form 
                    (concat 
		     (cond ((stringp form) form)
			   (t (prin1-to-string form)))
		     CR CR))
                  (title (concat title CR))
                  (t ""))
            (if descr (concat (break-lines descr 0) CR CR) "")
            (if content-model (concat "CONTENT MODEL FROM DTD: " content-model CR CR) "")
            (if parameters (concat "PARAMETERS:" CR (format-parameters parameters) CR CR) "")
            (if attribute-descriptions (concat "ATTRIBUTES:" CR (format-attribute-descriptions attribute-descriptions) CR CR) "")
            (if xml-in-laml-attributes (concat "XML-IN-LAML ATTRIBUTES:" CR (format-xml-in-laml-attributes xml-in-laml-attributes) CR CR) "")
            (if attributes (concat "RAW ATTRIBUTES FROM DTD:" CR (format-attributes attributes) CR CR) "")
            (if returns (concat "RETURNED VALUE:" CR (break-lines returns 0) CR CR) "")

    )))

(defun make-lines-of-string (str)
  "Return a list of lines, each approximately  schemedoc-preferred-linelength  chars long"
  (make-lines-of-string-1 str (length str)))

(defun make-lines-of-string-1 (str str-lgt)
  (let ((i (min (max (- schemedoc-preferred-linelength 4) 0) str-lgt)))
    (while (and (< i str-lgt) (not (member (aref str i) white-space-char-list))) (setq i (+ i 1)))
    (cond ((= i str-lgt) (list str))
          ((and (< i str-lgt) (member (aref str i) white-space-char-list)) 
              (cons 
                (substring str 0 i)
                (let ((rest-string  (substring str (+ i 1))))
                  (make-lines-of-string-1 rest-string (length rest-string)))))
          (t (error "make-lines-of-string: Should not happen" str str-lgt i)))))


(defun format-parameters (parameter-list)
  (apply (function concat) (mapcar (function format-one-parameter) parameter-list)))

(defun format-one-parameter (par)
  (concat " - " (cadr par) ":  " (break-lines (caddr par) 3) CR))

(defun format-attribute-descriptions (attribute-descriptions)
  (apply (function concat) (mapcar (function format-one-attribute-description) attribute-descriptions)))

(defun format-xml-in-laml-attributes (attribute-descriptions)
  (apply (function concat) (mapcar (function format-one-attribute) attribute-descriptions)))

(defun format-one-attribute-description (attribute-description)
  (concat " - " (cadr attribute-description) ":  " (break-lines (caddr attribute-description) 3) CR))

(defun format-attributes (attributes)
  (apply (function concat) (mapcar (function format-one-attribute) attributes)))

(defun format-one-attribute (attribute)
  (concat " - " (cadr attribute) ":  " (prin1-to-string (caddr attribute)) "  " (car (cdddr attribute)) CR))



(defvar white-space-char-list (list 9 10 13 32) "The list of white space characters") 

(defun break-lines (str indent) 
 "Break the string str into a number of lines. Indent lines after CR with indent spaces. Returned the line breaked string."
 (let* ((line-list (make-lines-of-string str))
        (line-list-lgt (length line-list))
        (indent-string (make-string indent 32)))
  (cond ((= 0 line-list-lgt) "")
        ((= 1 line-list-lgt) (car line-list))
        (t (let ((last-line (car (last line-list)))
                 (but-last-lines (butlast line-list)))
	     (concat 
	      (apply (function concat) (mapcar (function (lambda (ln) (concat ln CR indent-string))) but-last-lines))
	      last-line))))))

            
(defun assoc-get (key a-list)
  (let ((r (assq key a-list)))
    (if r (cadr r) nil)))

(defun assoc-get-cdr (key a-list)
  (let ((r (assq key a-list)))
    (if r (cdr r) nil))) 

(defun file-read-schemedoc (file-path)
  "Read the first Lisp expression from file (absolute or relative path)"
  (let ((abs-file-path (if (file-name-absolute-p file-path) (concat file-path ".manlsp") (concat (current-directory) file-path ".manlsp"))))
    (if (file-exists-p abs-file-path)  ; it may be a slim distribution
        (save-excursion
	  (let ((temp-buf (generate-new-buffer "file-reading.tmp")))
	    (set-buffer temp-buf)
	    (insert-file abs-file-path)
	    (goto-char (point-min))
	    (forward-char 1) (kill-sexp 1) ; deletes the header part of the read manlsp file 
	    (goto-char (point-min))
	    (prog1
		(read temp-buf)
	      (kill-buffer temp-buf))))
        nil
    )))

(defun schemedoc-file-number-of-name (name)
  "Return the number of the file where name is documented. Return nil if name is not found."
  (cdr (assoc name documented-scheme-names-alist)))

(defun file-path-of-file-number (n)
  "Return the file path of file number n i schemedoc-manlsp-file-list. The first file is given the number 1."
  (nth (- n 1) schemedoc-manlsp-file-list))  
  

(defun find-schemedoc-documentation-of-name-given-number (name file-number)
  "Return the approriate association list from an internal manlsp SchemeDoc file describing name. The information is found in file-number, relative to the list documented-scheme-names-alist."
  (if file-number 
      (let* ((manlsp-file-path (nth (- file-number 1) schemedoc-manlsp-file-list))
	     (manlsp-structure (file-read-schemedoc manlsp-file-path))
             (manlsp-structure-header nil) ; (car manlsp-structure)  ; We cannot yet read the header part due to occurrences of #t
             (scheme-source nil)  ; (assoc-get 'scheme-source-file manlsp-structure-header)
             (laml-resource nil)  ; (assoc-get 'laml-resource manlsp-structure-header)
	     (res (linear-search 
		   manlsp-structure  ; does not look in header part.
		   (function 
		    (lambda (el) 
		      (equal (assoc-get 'title el) name)))
		   (function (lambda (x) x)))))
	(if res
            
	    (cons (list 'laml-resource laml-resource) (cons (list 'scheme-source-file (scheme-source-file-path scheme-source laml-resource)) (cons (list 'source (file-name-nondirectory manlsp-file-path))  res)))
	  nil))
    nil))

(defun scheme-source-file-path (scheme-source laml-resource)
  (cond ((and scheme-source (equal laml-resource "true"))
            (substring scheme-source (length laml-dir)))
        (scheme-source scheme-source)
        (t nil))) 

(defun find-schemedoc-documentation-of-name (name)
  "Return the approriate association list from an internal manlsp SchemeDoc file describing name."
  (let ((file-number (schemedoc-file-number-of-name name)))  ; the number of the file in schemedoc-manlsp-file-list where to look for documentation
    (find-schemedoc-documentation-of-name-given-number name file-number)))




    
  


    